home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacHack 1994
/
MacHack 1994.toast
/
MacHack™94
/
Talks & Papers
/
Timothy Knox
/
Pocket6.3
/
Examples
/
Window&Menu
< prev
Wrap
Text File
|
1994-06-24
|
7KB
|
160 lines
( Window&Menu for Pocket Forth 0.6.3 )
( Be sure that you are running this demo on a COPY of )
( the Pocket Forth application [not the DA]. Close the )
( window if you need to quit and make a back up copy. )
( If this is a backup, press a key to continue. )
key drop
page 0 28 +md ! ( turn off screen echo )
forget task : task ; decimal
( First define some general purpose words to create resources )
( Macros for memory manager )
: >D0 ( n -- )
,$ 4280 ,$ 301E ; macro ( clr.l d0 move [a6]+,d0 )
: >A0 ( d -- ) ,$ 205E ; macro ( movea.l [a6]+,a0 )
: D0> ( -- n ) ,$ 3D00 ; macro ( move d0,-[a6] )
: A0> ( -- d ) ,$ 2D08 ; macro ( move.l a0,-[a6] )
( Memory management )
: MERROR ( -- ) ( aborts on error in d0 )
d0> ?dup IF ." Memory Error:" . abort THEN ;
: HNEW ( size -- handle ) ( create a new handle )
>d0 ,$ A122 a0> merror ; ( _NewHandle )
: HDISP ( handle -- ) >a0 ,$ A023 ; ( _DisposHandle )
: !HSIZE ( size handle -- ) ( set block size )
>a0 >d0 ,$ A024 merror ;
( relocatable block definition )
2variable NBH 0 0 nbh 2! ( New Block Handle holder )
variable BOFFSET 0 boffset ! ( offset into the block )
: ?B; ( -- flag ) ( true if "B;" is at here )
here 2@ 578 = swap 15104 = and ;
: BLOCK ( -- ) ( create a new 32K block )
0 boffset ! [ 32 1024 * literal ] hnew nbh 2! ;
: :B ( -- ) ( compile numbers to the block with handle at nbh )
BEGIN
token ?b; 0= WHILE ( while next word is not b; )
here number IF ( If it's a number )
nbh 2@ dl@ ( dereference handle )
boffset @ s>d d+ l! ( store n at d.pointer+offset )
2 boffset +! ( advance boffset )
ELSE nbh 2@ hdisp ( not a number must be an error )
cr ." Data error at word: " boffset @ . abort THEN
REPEAT ;
: EBLOCK ( -- dhandle ) ( finish a block creation )
boffset @ nbh 2@ !hsize nbh 2@ ;
( resource addition and removal )
: RERROR ( -- ) ( check for resource error )
0 >r ,$ A9AF r> ?dup ( _ResError )
IF ." Resource error: " . abort THEN ;
: RGET ( id dtype -- dhandle ) ( get a resource handle )
0 0 2>r 2>r >r ,$ A9A0 2r> rerror ; ( _GetResource )
: RREMOVE ( dhandle -- ) 2>r ,$ A9AD ; ( _RmveResource no err )
: +RSC ( id dtype dhandle -- ) ( _AddResource to current file )
2>r 2>r >r 0 0 here 2! here a>r ,$ A9AB rerror ;
: -RSC ( id dtype -- ) ( dispose of a resource )
rget 2dup rremove hdisp ;
hex ( create the MENU resource )
4 ,s MENU -rsc ( remove any old MENU #4 )
4 ,s MENU ( type of resource to create )
block ( put the following data into a relocatable block )
:b 0004 0000 0000 0000 0000 FFFF FFDB 0657 b;
:b 696E 646F 770B 4869 6465 2057 696E 646F b; \ get these..
:b 7700 4800 0001 2D00 0000 000C 536D 616C b; \ ..numbers..
:b 6C20 5769 6E64 6F77 0000 0000 0C4C 6172 b; \ ...from...
:b 6765 2057 696E 646F 7700 0012 0001 2D00 b; \ ..ResEdit
:b 0000 000B 5361 7665 2057 696E 646F 7700 b;
:b 4D00 0000 b;
eblock +rsc ( add a resource to Pocket Forth )
( Now the resources are created and installed so the )
( resource creating and installing routines are not needed )
decimal forget task
( Window pointer, menu handle and strings )
: WINDOW ( -- window.pointer ) 0 +md 2@ ;
2variable SMENUH ( to hold the handle to the menu )
: ," ( -- ) ( compile a quoted string from input stream )
34 word here c@ 1+ dup 2 mod + allot ; IMMEDIATE
( Show and hide the window, with toggling menu stuff. )
create "HIDE" ," Hide Window" ( string data )
create "SHOW" ," Show Window" ( string data )
variable ?HIDDEN 0 ?hidden !
: HIDE ( -- )
-1 ?hidden !
smenuh 2@ 2>r 1 >r "show" a>r ,$ A947 ( _SetItem )
window 2>r ,$ A916 ; ( _HideWindow )
: SHOW ( -- )
0 ?hidden !
smenuh 2@ 2>r 1 >r "hide" a>r ,$ A947 ( _SetItem )
window 2>r ,$ A915 ; ( _ShowWindow )
: HIDE/SHOW ?hidden @ IF show ELSE hide THEN quit ;
( Window size manipulation and menu checking )
: WSIZE ( h v -- ) ( change the window size )
2dup 8 +md 2! ( set the scroll rect )
window 2>r 2>r 256 >r ,$ A91D ; ( _SizeWindow )
: WTINY ( -- ) ( make the window a two liner )
384 24 wsize show
smenuh 2@ 2>r 3 >r -1 >r ,$ A945 ( _CheckItem 3 )
smenuh 2@ 2>r 4 >r 0 >r ,$ A945 cr quit ; ( [un]_CheckItem 4 )
: WNORM ( -- ) ( bring back the normal sized window )
384 178 wsize show
smenuh 2@ 2>r 4 >r -1 >r ,$ A945 ( _CheckItem 4 )
smenuh 2@ 2>r 3 >r 0 >r ,$ A945 ; ( [un]_CheckItem 3 )
( Save the window's contents in a picture. )
4 +md constant WRECT ( addr of window's rect )
: WPICT ( -- dhandle ) ( the window picture's handle )
0 0 2>r window 2>r ,$ A92F 2r> ; ( _GetWindowPic )
: KPIC ( d -- ) 2dup or IF 2>r ,$ A8F5 ELSE 2drop THEN ;
: PICTURE ( rect -- dhandle ) ( open a picture leave its handle )
0 0 2>r a>r ,$ A8F3 2r> ; ( _OpenPicture )
: PCLOSE ( -- ) ,$ A8F4 ; macro ( _ClosePicture )
: PKILL ( addr -- ) 2@ kpic ; ( _KillPicture at addr )
: WPASSIGN ( handle -- ) ( ASSIGN a Picture to Window )
window 2>r 2>r ,$ A92E ; ( _SetWindowPic )
: BCOPY ( rect -- ) ( copy window bitmap to window )
window 2 0 d+ 2dup 2>r 2>r ( window bits = source, destination )
dup a>r a>r 0 >r ( source rect, destination rect, mode )
window 24 0 d+ dl@ 2>r ( mask to port visrgn )
,$ A8EC ; ( SrcCopy mode, _CopyBits )
: WSAVE ( -- ) ( save the screen for updating )
wpict kpic ( _KillPicture )
0 0 window 148 0 d+ dl! ( zero window picture in window record )
wrect picture wpassign wrect bcopy pclose ;
( Now create the menu arrays -- see Pocket Forth manual )
create StuffMenu ( a list of words for your menu items )
' hide/show , ' null ,
' wtiny , ' wnorm , ' null ,
' wsave ,
create NewMenuList ( a list of lists of your menubar )
18 +md @ @ , ( addr of existing File menu list )
18 +md @ 2+ @ , ( ditto for Edit menu list )
StuffMenu , ( and now Your menu )
: NUBYE ( remove MENU resource before quitting )
smenuh 2@ 2>r ,$ A9A3 ( _ReleaseResource )
0 0 2>r ,s MENU 2>r 4 >r
,$ A9A0 ,$ A9AD ( _GetResource _RemoveResource )
bye ; ( do the regular quit routine )
' nubye 22 +md ! ( store this new quit routine )
: TASK ; ( added 5/29/92 )
: +MENU ( -- ) ( Turn the new menu on.)
NewMenuList 18 +md ! ( store the new menubar list )
0 0 2>r 4 >r ,$ A9BF ( _GetRMenu )
2r> 2dup 2>r 0 >r ,$ A935 ( _InsertMenu )
smenuh 2! ,$ A937 ; ( _DrawMenuBar )
+menu forget +menu
page -1 28 +md ! ( turn on screen echo )
( Use the new “Windows” menu to manipulate the )
( Pocket Forth window. )